;;; Lepton EDA netlister
;;; Copyright (C) 1998-2010 Ales Hvezda
;;; Copyright (C) 1998-2017 gEDA Contributors
;;; Copyright (C) 2017-2023 Lepton EDA Contributors
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.

(define-module (backend allegro)
  ;; Allegro netlist format
  #:use-module (netlist)
  #:use-module (netlist schematic)
  #:use-module (netlist error)
  #:use-module (netlist schematic toplevel)
  #:use-module (netlist package)

  #:export (allegro
            allegro*))

(define (allegro:write-device-files packages done stdout)
  (unless (null? packages)
    (let* ((package (car packages))
           (device (package-attribute package 'device)))
      (if (member device done)
          (allegro:write-device-files (cdr packages) done stdout)
          (begin
            (if stdout
                (allegro:output-netlist package)
                (with-output-to-file (allegro:check-and-get-filename device package)
                  (lambda ()
                    (allegro:output-netlist package))))
            (allegro:write-device-files (cdr packages) (cons device done) stdout))))))

(define (allegro:check-and-get-filename device package)
  (let ((filename (string-downcase! (string-append "devfiles/" (string-append device ".txt")))))
    ;; Check if the 'devfiles' directory exist.
    (if (not (access? "devfiles" F_OK))
        (if (access? "." W_OK)
            ;; If the 'devfiles' directory doesn't exist, and
            ;; we have write access to the current directory, then create it.
            (mkdir "devfiles")
            ;; If we don't have write access to the current directory,
            ;; end with an error message.
            (netlist-error 1
                           "The device files are expected to be in the 'devfiles' directory.
       However, can't create it!.
       Check write permissions of the current directory.\n"))
        ;; If 'devfiles' exist, check if it is a directory.
        (unless (eq? (stat:type (stat "devfiles")) 'directory)
          ;; 'devfiles' exists, but it is not a directory.
          ;; End with an error message.
          (netlist-error 1
                         "The device files are expected to be in the 'devfiles' directory.
       However, 'devfiles' exists and it is not a directory!.\n")))
    ;; 'devfiles' should exist now. Check if we have write access.
    (unless (access? "devfiles" W_OK)
      ;; We don't have write access to 'devfiles'.
      ;; End with an error message
      (netlist-error 1
                     "The device files are expected to be in the 'devfiles' directory.
       However, can't access it for writing!.
       Check write permissions of the 'devfiles' directory.\n"))

    ;; Return value.
    filename))

(define (allegro:output-netlist package)
  (let* ((altfoot (package-attribute package 'alt_foot))
         (package-prop (if altfoot
                           (format #f
                                   "PACKAGEPROP   ALT_SYMBOLS\n'(~A)'\n"
                                   altfoot)
                           "")))
    (format #t
            "(Device File generated by Lepton EDA netlister Allegro backend)
PACKAGE ~A
CLASS ~A
PINCOUNT ~A
~AEND
"
            (package-attribute package 'footprint)
            (package-attribute package 'class)
            (package-attribute package 'pins)
            package-prop)))

(define (allegro:components packages)
  (unless (null? packages)
    (let ((package (car packages)))
      (format #t "~A! ~A! ~A; ~A\n"
              (or (package-attribute package 'footprint) "")
              (package-attribute package 'device)
              (or (package-attribute package 'value)
                  (package-attribute package 'label)
                  (package-attribute package 'device))
              (package-refdes package)))
    (allegro:components (cdr packages))))


(define (connections->string connections)
  (define package car)
  (define pinnumber cdr)
  (define (connection->string connection)
    (format #f " ~A.~A" (package connection) (pinnumber connection)))
  (string-join (map connection->string connections) ",\n"))

(define (nets->allegro-netlist netnames schematic)
  (define (net->string netname)
    (format #f "~A;~A\n"
            netname
            (connections->string (get-connections netname schematic))))
  (map net->string netnames))

(define* (allegro* schematic #:key output-filename)
  (let ((use-stdout? (not output-filename))
        (packages (schematic-packages schematic))
        (nets (schematic-nets schematic)))
    (display "(Allegro netlister by M. Ettus)\n")
    (display "$PACKAGES\n")
    (allegro:components packages)
    (display "$NETS\n")
    (for-each display
              (nets->allegro-netlist nets schematic))
    (display "$END\n")
    (allegro:write-device-files packages '() use-stdout?)))

(define (allegro)
  (allegro* (toplevel-schematic)
            #:output-filename (netlist-output-filename)))
